perm filename TR3.F4[P11,LCS] blob
sn#341679 filedate 1978-03-12 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE MSCAN(LL,W)
C00017 ENDMK
C⊗;
SUBROUTINE MSCAN(LL,W)
DIMENSION RX(100),W(1),TONES(21)
COMMON /TR/I(80),JX(100),NN(2),LX(12),INST(27,5),MX5(40)
1,INSNUM(27),FQDR(5/32,27),P(30),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
C OUT, OSC, AD2, RAN, ENV, STR, AD3, AD4, MLT, SET, RAH, GEN
INTEGER FQDR,RPR
EQUIVALENCE (IZR,RZR),(LESS,LX(9)),(RX,JX),
1 (INN,RNN),(RX2,RX(3)),(P2,P(2)),(RX3,RX(5)),(I3,I(3))
1 ,(ISEMI,LX(2)),(IAST,LX(3))
1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(LAROW,LX(7))
DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
1 329.63,349.23,329.63,349.23,369.99,369.99,
1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/
CCC DATA M5/'OUT','OSC','AD2','RAN','ENV','STR','AD3',
CCC 1'AD4','MLT','SET','RAH','END'/
C**** CODE NUMS. 1=OUT 2=OSC 3=AD2 4=RAN 5=END 6=STR 7=AD3 8=AD4 9=MLT
C**** 10=SET 11=RAH 12=END 13=INS B1=101 ETC. P1=201 ETC. F1=301 ETC.
C**** 400=PLAY 401=FINI 402=SRATE 403=NCHNS 404=PRINT 405=CHA 406=POWER
C**** 407=SRT 409=GEN 410=DUR 411=FREQ 412=INSTRUMENT 413=UNIT GEN.
C**** 500=CF 501=C 502=CS 503=DF 504=D 505=DS 506=EF 507=E 508=ES 509=FF
C**** 510=F 511=FS 512=GF 513=G 514=GS 515=AF 516=A 517=AS 518=BF 519=B 520=BS
30 IF(JSEM.NE.0)GO TO 34
LL=1
INS=-1
34 J=J+2
IPP=0
C!FOR 'P3←333;' ETC.
IPOW=0
IOP=-1
IXJ=JX(J)
IF(IXJ.NE.ISEMI)GO TO 9
10 IF(IGEN.GT.100)W(3)=IGEN
15 JSEM=-1
RETURN
9 IF(J.GE.MM)GO TO 1001
IF(RX(J+1).EQ.-9999.0)GO TO 11
C!*** SKIP IF NUMBER
IF(IGEN.GT.0)GO TO 450
CC DO 32 K=1,11
C!***** LOOK FOR SPECIAL WORDS
CC32 IF(IWD(K).EQ.IXJ)
CC 1 GO TO (3,13,13,304,303,302,303,4,505,505,422)K
IF(IXJ/400.NE.1)GO TO 32
K=IXJ-399
GO TO (3,13,304,303,302,303,4,505,505,422)K
32 IF(IXJ.NE.13)GO TO 402
CCC IF(IXJ.NE.'INS')GO TO 402
KNAM=IXJ
W(1)=2
IGEN=2
GO TO 424
505 JK=4
C !**** FOR SRATE OR SRT
IF(K.NE.4)JK=2
JK=J+JK
GO TO 304
CC450 DO 400 K=1,12
CC400 IF(IXJ.EQ.M5(K))GO TO(425,425,425,425,425,425,425,425
CC 1,425,425,425,411),K
450 K=IXJ
C** HERE FOR INST DEFINITIONS.
IF(K.LE.13.AND.K.GT.0)GO TO(425,425,425,425,425
1,425,425,425,425,425,425,411),K
DO 451 JK=1,40,2
C!*** FOR USER-ADDED UNIT GENS. (UP TO 20)
IF(MX5(JK).NE.IXJ)GO TO 451
W(3)=MX5(JK+1)
GO TO 426
451 CONTINUE
503 TYPE 504,IXJ
JSEM=0
J=MM
RETURN
504 FORMAT(' UNKNOWN SYMBOL ',A5)
411 LL=3
KNAM=IXJ
IGEN=1
C!*** =1 IS FLAG TO CHANGE IT TO -1
J=MM
INS=-1
GO TO 10
422 W(1)=3
C!***** GEN
KNAM=IXJ
IGEN=0
424 INS=-1
LL=2
GO TO 36
425 W(3)=K+100
426 KNAM=IXJ
436 LL=4
GO TO 36
3 J=J+2
C !**** FOUND 'PLAY;'
IF(JX(J).NE.ISEMI)CALL ERR(1)
IPLAY=-1
CCC SBFILN='TEST'
CCC CALL PUTFIL(SBFILN)
CCC CALL FASTOU(I,128)
C THE HEADER (SUCH AS IT IS) USETO IN MAIN PROG.
JSEM=-1
IF(J.LT.MM)GO TO 34
JSEM=0
RETURN
4 JL=LL
JOP=IOP
J=J+2
IF(JX(J).NE.LPR)CALL ERR(2)
IPOW=-1
IOP=-1
GO TO 36
C!**FIND NUM UP TO THE COMMA
7 IF(IPOW.GT.0)GO TO 8
IPOW=1
GO TO 36
8 LL=LL-2
W(LL)=W(LL)**W(LL+1)
IPOW=0
IOP=JOP
C!** GET BACK FLAGS
GO TO 38
302 LL=1
IPRNT=-1
C!***** FOR 'PRINT' FEATURE
GO TO 36
304 SRATE=RX(J+4)
J=J+6
RMAG=512./SRATE
W(3)=4
W(4)=SRATE
351 W(1)=11
W(2)=0
IGEN=0
LL=5
GO TO 15
303 IF(IXJ.EQ.'CHA')J=J-2
RNCHN=RX(J+4)
C!**** FOR NCHNS←N;
J=J+6
CC IF(RX(JK+1).NE.-9999.0)JK=JK+2
C!*** SKIP A COMMA
CC IF(JX(JK+2).EQ.ISEMI)GO TO 352
C!*** FOR NCHNS←n;
352 W(3)=8
C!*** FOR NCHNS
W(4)=RNCHN-1
GO TO 351
35 IF(IPLAY.GE.0)CALL ERR(4)
W(2)=INSNUM(IK)
C!**** W IS P ARRAY IN MUSIC5
LL=3
C!**** W(2) AND W(3) WILL BE EXCHANGED LATER
KNAM=IXJ
36 J=J+2
IF(J.GT.MM)GO TO 1001
C!****** 50 = DONE
CC JK=J*2
IXJ=JX(J)
IF(IXJ.NE.ISEMI)GO TO 1
JSEM=-1
1000 IF(IPP.EQ.0)GO TO 10
P(IPP)=W(1)
LL=1
IPP=0
IF(J.LT.MM)GO TO 30
INS=-1
C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
1001 IF(IGEN.EQ.0.OR.JSEM.EQ.0)JSEM=1
IF(JSEM)JSEM=0
RETURN
1 IF(RX(J+1).NE.-9999.0)GO TO 2
11 IF(IOP)GO TO 40
IF(IOP.NE.5)GO TO 12
RX(J)=-RX(J)
C!*** IOP=5 MEANS MINUS WITH COMMA IN FRONT
W(LL)=RX(J)
LL=LL+1
GO TO 14
12 CALL ARITH(RX(J),W,LL)
14 IOP=-1
C!*** RESET OPERATOR FLAG
GO TO 36
C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!
40 W(LL)=RX(J)
38 LL=LL+1
IF(IOP)GO TO 36
C IOP = NEG = NO OPERATOR BEFORE THIS ITEM.
LL=LL-1
380 CALL ARITH(W(LL),W,LL)
GO TO 14
402 IF(JSEM.GT.0)GO TO 2
C!**** READING CONTINUATION LINE.
IF(IXJ.GE.0)GO TO 33
C NEXT TRIES TO FIND INST. NAME.
NA=-1-IXJ
M=JX(J+1)
C NA POINTS TO SPOT IN I ARRAY, M IS WDCNT.
DO 133 IK=1,INUM
DO 233 II=1,M
233 IF(INST(IK,II).NE.I(II+NA))GO TO 133
C NOW WE FOUND AN INST. NAME.
C******* INST NAMES CANNOT HAVE SAME STRING OF 1ST LETTERS AS OTHER THINGS.
333 IF(M.EQ.5)GO TO 35
M=M+1
IF(INST(IK,M).EQ.0)GO TO 333
133 CONTINUE
CC DO 33 IK=1,INUM
CC33 IF(IXJ.EQ.INST(IK))GO TO 35
33 INS=2
C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.
2 IF(IGEN.GT.0)GO TO 427
CCC DO 306 K=1,21
CCC IF(IXJ.NE.ISCL(K))GO TO 306
IF(IXJ.GT.520)GO TO 341
IF(IXJ.LT.500)GO TO 427
C NOW FOUND A NOTE
K=IXJ-499
W(LL)=TONES(K)
CC JK=K
CC CALL NOTES(JK,W(LL))
GO TO 38
CCC306 CONTINUE
C!***** FINDS NOTE IN SCALE
CC427 DO 307 K=1,40
C!****** FIND A PARAM NUM.
CC IF(IXJ.NE.IPARS(K))GO TO 307
427 IF(IXJ.GE.300)GO TO 307
IF(IXJ.LT.200)GO TO 344
K=IXJ-200
C NOW K HAS PARAM NUM.
IF(INS.LE.0)GO TO 340
JK=J+2
IF(JX(JK).NE.LAROW)GO TO 340
IPP=K
LL=1
J=JK
GO TO 36
340 W(LL)=P(K)
C!***** FOUND Pn
IF(IPRNT)GO TO 38
IF(IGEN.GT.0)W(LL)=K+2.
C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
GO TO 38
C!**** P4 IS CHANGED TO 6
307 IF(IXJ.GE.400)GO TO 344
CC DO 344 K=1,30
CC IF(IXJ.NE.IFUN(K))GO TO 344
IF(IXJ/300.NE.1)GO TO 344
CCC JL=K
JL=IXJ-300
IF(IGEN.GT.0)JL=-JL-100
C!*** FOR Fn IN INST DEFINITION
W(LL)=JL
GO TO 38
344 CONTINUE
IF(IGEN.LE.0)GO TO 341
CC DO 342 K=1,20
CC IF(IXJ.NE.IB(K))GO TO 342
C*** FOR B1, ETC. IN INST. DEFS.
IF(IXJ/100.NE.1)GO TO 341
W(LL)=100-IXJ
CCC W(LL)=-K
GO TO 38
342 CONTINUE
341 DO 39 K=3,6
IF(LX(K).NE.IXJ)GO TO 39
IOP=K-2
JK=JX(J-2)
IF(JK.EQ.ICOM)IOP=5
C!** COMMA DISABLES NEXT OPERATOR
IF(JK.EQ.LAROW)IOP=5
C!** ← DISABLES NEXT OPERATOR
IF(JK.EQ.LPR)IOP=5
C!** LFT PARENTH. DISABLES NEXT OPERATOR
GO TO 36
39 CONTINUE
308 IF(IXJ.EQ.LAROW)GO TO 36
C!*** PASS LEFT ARROW
C**** OR SHOULD NEXT BE 406???
IF(IXJ.EQ.406)GO TO 4
CC IF(IXJ.EQ.IPWR)GO TO 4
IF(IXJ.EQ.RPR)GO TO 500
IF(IXJ.EQ.LPR)GO TO 500
C**** OR SHOULD NEXT BE 402???
IF(IXJ.NE.402)GO TO 510
CC IF(IXJ.NE.JSRT.AND.IXJ.NE.ISRT)GO TO 510
W(LL)=SRATE
335 LL=LL+1
GO TO 36
C**** OR SHOULD NEXT BE 403???
510 IF(IXJ.NE.403)GO TO 511
CC510 IF(IXJ.NE.NCHNS)GO TO 511
W(LL)=RNCHN
GO TO 335
511 IF(IXJ.NE.ICOM)GO TO 503
C!***** UNKNOWN CHAR.
500 IF(IPOW.NE.0)GO TO 7
IF(IXJ.NE.LPR)GO TO 501
JPOW=IPOW
IPOW=0
KOP=IOP
IOP=-1
JL=LL
C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
GO TO 36
501 IF(IXJ.NE.RPR)GO TO 502
IPOW=JPOW
C!*** GET BACK STUFF
IOP=KOP
CC LL=JL+1 !**?????
IF(IOP)GO TO 36
LL=JL
GO TO 380
C!GO DO ARITHMETIC
502 IF(IPRNT)GO TO 36
C!**** FOUND COMMA IN PRINT STATEMENT.
5 IF(JX(J-2).NE.ICOM)GO TO 132
433 W(LL)=P(LL-2)
C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
GO TO 335
132 IF(INS.GE.0)GO TO 36
IF(LL.EQ.3)GO TO 433
C!*** =3 MEANS COMMA FOR P1.
GO TO 36
13 LL=2
IPLAY=0
C!*** TURN OFF PLAY FLAG
W(1)=6
W(2)=ENDX+.5
C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
IF(JPRNT)TYPE 51,LL,W(1),W(2)
IF(JWRT.GE.0)GO TO 130
WRITE(21)LL,W(1),W(2)
END FILE 21
IOPEN=-1
TYPE 131,JFLNM
130 J=MM
JSEM=99
C!*** WON'T READ LINE BEYOND 'FINISH;' ***************
ENDX=-1
51 FORMAT(I3,35F10.3)
131 FORMAT(9X,A5,'.DAT WAS WRITTEN *****')
END